home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Hacks / Hacks ’87 / Source ƒ.sit / Source ƒ / lisp source / match.sch < prev   
Encoding:
Text File  |  1986-08-10  |  2.9 KB  |  62 lines  |  [TEXT/EDIT]
  1. ;  MATCH from _LISP_, Winston & Horn, Chapter 17
  2. ;  the 'restriction' feature is not implemented because I haven't figured
  3. ;  out how to implement FUNCALL in MacScheme yet
  4. ;  Greg Grubbs, Aug. 86     GEnie: G.GRUBBS
  5. (define (match p d assignments)
  6.   (cond ((and (null? p) (null? d))                ; end o' line->succeed
  7.          (cond ((null? assignments) t)
  8.                (else assignments)))
  9.         ((or (null? p) (null? d)) nil)            ; fail
  10.         ((or (equal? (car p) '?)                  ; match ? pattern
  11.              (equal? (car p) (car d)))            ; elements are identical
  12.          (match (cdr p) (cdr d) assignments))
  13.         ((equal? (car p) '+)                      ; MATCH + pattern
  14.          (or (match (cdr p) (cdr d) assignments)
  15.              (match p (cdr d) assignments)))
  16.         ((atom? (car p)) nil)                     ; losing atom
  17.         ((equal? (pattern-indicator (car p)) '>)  ; MATCH > variable
  18.          (match (cdr p) (cdr d)
  19.                         (shove-gr (pattern-variable (car p))
  20.                                   (car d)
  21.                                   assignments)))
  22.         ((equal? (pattern-indicator (car p)) '<)  ; SUBSTITUTE variable
  23.          (match (cons (pull-value (pattern-variable (car p)) assignments)
  24.                       (cdr p))
  25.                 d
  26.                 assignments))
  27.         ((equal? (pattern-indicator (car p)) '+)  ; MATCH + variable
  28.          (let ((new-assignments (shove-pl (pattern-variable (car p))
  29.                                           (car d)
  30.                                           assignments)))
  31.            (or (match (cdr p) (cdr d) new-assignments)
  32.                (match p (cdr d) new-assignments))))
  33.         ;((and (equal? (pattern-indicator (car p))  ; MATCH ? restrictions
  34.         ;              'restrict)
  35.         ;      (equal? (restriction-indicator (car p)) '?)
  36.         ;      (test (restriction-predicates (car p)) (car d)))
  37.         ; (match (cdr p) (cdr d) assignments))
  38.         ))
  39.  
  40. (define (shove-gr variable item a-list)
  41.   (append a-list (list (list variable item))))
  42. (define (pattern-indicator l)
  43.   (car l))
  44. (define (pattern-variable l)
  45.   (cadr l))
  46. (define (pull-value variable a-list)
  47.   (cond ((null? a-list) nil)
  48.         (else (cadr (assoc variable a-list)))))
  49. (define (shove-pl variable item a-list)
  50.   (cond ((null? a-list) (list (list variable (list item))))
  51.         ((equal? variable (caar a-list))
  52.          (cons (list variable (append (cadar a-list) (list item)))
  53.                (cdr a-list)))
  54.         (else (cons (car a-list)
  55.                     (shove-pl variable item (cdr a-list))))))
  56. ; (define (restriction-indicator pattern-item) (cadr pattern-item))
  57. ; (define (restriction-predicates pattern-item) (cddr pattern-item))
  58. ; (define (test predicates argument)
  59. ;   (cond ((null? predicates) t)
  60. ;         ((FUNCALL (car predicates) argument)
  61. ;          (test (cdr predicates) argument))
  62. ;         (else nil)))